Private Sub wsckArrPing_DataArrival(Index As Integer, ByVal bytesTotal As Long)
' PONG! We just get an answer from the destination host so we save this result quickly!
' Rasing this result to the user is a job of the timer loop "tmrSchedule_Timer()".
arrThreads(Index).flgPong = True
End Sub
Private Sub wsckArrPing_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
' Give the error to the user
RaiseError PP_ERR_WINSOCK, "WinSock control pinging to '" & arrThreads(Index).sIPadr & "' gots error [" & Description & "]"
End Sub
Private Sub tmrSchedule_Timer()
' Main action starts here:
'
' When enabled and there are hosts to check in queue create 'threads'
' to check the destination hosts by using a WinSock control array.
' 'Ping' is realized by opening a connection to ICMP (Ping) port 7.
Dim i As Long
Dim lStartSearch As Long
Dim lIndexFree As Long
Dim EmptySlot As tpThread
On Local Error GoTo tmrSchedule_Timer_Error
With VAR
' === PART 1 : Handle running 'threads' first to get free slots for new 'threads'
If .lOpenPings > 0 Then
For i = 1 To wsckArrPing.Count ' Check allocated slots (1..n)
With arrThreads(i)
If .flgPong = True Then ' Did we got an answer to the Ping call?
RaiseEvent Pong(.sIPadr, .lID, True) ' Let the world know we got an answer!
Let arrThreads(i) = EmptySlot ' Free thread
VAR.lOpenPings = VAR.lOpenPings - 1 ' One less
ElseIf Len(.sIPadr) Then ' Used slot?
If .lStartTime + VAR.lTimeout < Int(Timer()) Then ' Is 'thread' timed out?
RaiseEvent Pong(.sIPadr, .lID, False) ' Let the world know we didn't got an answer!
Let arrThreads(i) = EmptySlot ' Free thread
VAR.lOpenPings = VAR.lOpenPings - 1 ' One less
End If
' Else Do nothing and go on waiting
End If
End With
' Abort check if no more runnings or user called Abort()
If .lOpenPings = 0 Then
Exit For
End If
Next i
' User has disabled and we are not waiting for results of running Pings anymore
If .lOpenPings = 0 And VAR.State = PP_DISABLED Then
' No more checking the lists
tmrSchedule.Enabled = False
Exit Sub
End If
ElseIf .lWaitingInQueue = 0 Then ' All is done -> stop timer!
' No more checking the lists
tmrSchedule.Enabled = False
Exit Sub
End If
' Abort request by user ?
If VAR.State = PP_ABORT_PENDING Then
' Clear 'thread' list
For i = 1 To wsckArrPing.Count
Let arrThreads(i) = EmptySlot
Next i
' Don' check lists anymore
tmrSchedule.Enabled = False
' Set new state
SetStateTo PP_DISABLED
Exit Sub
End If
DoEvents
' === PART 2 : Create new 'threads' if entries are waiting in queue
lStartSearch = 1 ' Start index for search in "thread"-list
Do While .lWaitingInQueue > 0 And _
.lOpenPings < .lMaxThreads And _
VAR.flgEnabled = True ' Entries are waiting, we have free slots and
' control is enabled
SetStateTo PP_BUSY
' Search for a free slot within current lists dimension
lIndexFree = 0 ' 0 = Not found a free slot
For i = lStartSearch To wsckArrPing.Count
If Len(arrThreads(i).sIPadr) = 0 Then
lIndexFree = i ' Found a free slot
lStartSearch = lIndexFree + 1
Exit For
End If
Next i
' If we still need a free slot
If lIndexFree = 0 And wsckArrPing.Count < .lMaxThreads Then ' Not found a free slot, but space for a new one
lIndexFree = wsckArrPing.Count + 1
Load wsckArrPing(lIndexFree) ' Load a new WinSock control in control array
lStartSearch = lIndexFree + 1 ' In this way we don't search for a free slot
End If ' on the next cycle of this big loop.
' If we still don't have a free slot so we must abort for this time
If lIndexFree = 0 Then
Exit Do
End If
' Now all its done for the Ping
With arrThreads(lIndexFree)
.sIPadr = arrQueueDestHosts(VAR.lNxtItemToTakeFromQueue).sIPadr ' Take next item from ringbuffer and
.lID = arrQueueDestHosts(VAR.lNxtItemToTakeFromQueue).lID ' put it into 'thread' list
.lStartTime = Int(Timer())
.flgPong = False
wsckArrPing(lIndexFree).RemoteHost = .sIPadr ' HERE we "PING" to the dest host just by opening
wsckArrPing(lIndexFree).SendData "<PONG this!>" ' a connection to port 7 and sending a string.
End With
' Handle ringbuffer
.lOpenPings = .lOpenPings + 1 ' One more open Pings we wait for
.lWaitingInQueue = .lWaitingInQueue - 1 ' One less in queue to do
